Pascal Super Library/Pascal Super Library (CW International)(1997).bin/EDIT_UTL/TRIVED09/GENERICF.PAS

Pascal/Delphi Source File | 1995-04-22 | 30KB | 1,595 lines

unit genericf;  {generic functions unit - not rnr-specific at all}

{

Russell Schulz - [e-mail] (950216)

Copyright 1995 Russell Schulz

this code is not in the Public Domain

permission is granted to use these routines in any application regardless
of commercial status as long as the author of these routines assumes no
liability for any damages whatsoever for any reason.  have fun.

}

{
version of this unit: 1ish
}

{$define floatingpoint}
{$undef floatingpoint}

interface

uses dos;

const
  tab=#9;

function max(a,b: integer): integer;
function min(a,b: integer): integer;
function wordtozstring(w: word; width: integer): string;
function integertozstring(i: integer; width: integer): string;
function longtozstring(l: longint; width: integer): string;
function time: string;
function timedigits: string;
function dow: integer;
function cdow: string;
function dayofmonth: integer;
function month: integer;
function extmonthname(themonth: integer): string;
function monthname: string;
function year: integer;
function getenv(s: string): string;
function numoccur(c: char; s: string): integer;
function hasany(c: char; s: string): boolean;
function hasno(c: char; s: string): boolean;
function unquote(s: string): string;
function crepl(s: string; cold, cnew: char): string;
function unslash(s: string): string;
function unbackslash(s: string): string;
function ununderscore(s: string): string;
function uncomma(s: string): string;
function srepl(s: string; sold, snew: string): string;
function unspace(s: string): string;
function atow(s: string): word;
function atoi(s: string): integer;
function atol(s: string): longint;
function wtoa(w: word): string;
function itoa(i: integer): string;
function ltoa(l: longint): string;
function lowcase(c: char): char;
function upper(s: string): string;
function lower(s: string): string;
function proper(s: string): string;
function ltrim(s: string): string;
function trim(s: string): string;
function right(s: string; i: integer): string;
function getfirstw(s: string): string;
function chopfirstw(var s: string): string;
function getquoted(s: string): string;
function randomletter: char;
function randomdigit: char;
function getfromaddr(from: string): string;
function getfromname(from: string): string;
function chop(s: string; i: integer): string;
function nore(s: string): string;
function monthstringtointeger(monthstr: string): integer;
function isalpha(c: char): boolean;
function isdigit(c: char): boolean;
function islower(c: char): boolean;
function snatchint(var s: string): integer;
function isdev(s: string): boolean;
function illegalfn(fn: string): boolean;
function suspiciousfn(fn: string): boolean;
function highestartin(groupdir: string): word;
function getuniqfile(groupdir: string): string;
function getuniqfext(basename: string): string;
function expand(str: string): string;
function rot13(s: string): string;
function indir(filespec,dir: string): boolean;
function default(defaultstr,possiblyemptystr: string): string;
function rpos(sub: string; whole: string): integer;
function rposc(s: string; c: char): integer;
function fexists(fn: string): boolean;
function dexists(dn: string): boolean;
function ftimestamp(fn: string): longint;
function withbackslash(s: string): string;
function nobeep(s: string): string;
function nonastychar(s: string): string;
function gettag(tag: string; s: string): string;
function hexchar(i: integer): char;
function partialmatch(cmd, template, minimum: string): boolean;
function doserrorno: byte;
function wordwith(c:char; s: string): string;
function isasciifile(fn: string): boolean;

{$ifdef VER40}
function dosversion: word;
{$endif}

{$ifdef floatingpoint}
function ator(s: string): real;
function rtoa(r: real): string;
function rwptoa(r: real; width: integer; precision: integer): string;
{$endif}

implementation

function max;

begin
  if a>b then max := a else max := b;
end;

function min;

begin
  min := -max(-a,-b);
end;

function wordtozstring;

var
  result: string;

begin
  str(w,result);

  while length(result)<width do
    result := '0'+result;

  wordtozstring := result;
end;

function integertozstring;

var
  result: string;

begin
  str(i,result);

  while length(result)<width do
    result := '0'+result;

  integertozstring := result;
end;

function longtozstring;

var
  result: string;

begin
  str(l,result);

  while length(result)<width do
    result := '0'+result;

  longtozstring := result;
end;

function time;

var
  h,m,s,s00: word;

begin
  gettime(h,m,s,s00);
  time :=
   integertozstring(h,2)+':'+integertozstring(m,2)+':'+integertozstring(s,2);
end;

function timedigits;

var
  h,m,s,s00: word;

begin
  gettime(h,m,s,s00);
  timedigits :=
   integertozstring(h,2)+integertozstring(m,2)+integertozstring(s,2);
end;

function dow;

var
  y,m,d,realdow: word;

begin
  getdate(y,m,d,realdow);
  dow := realdow;
end;

function cdow;

var
  result: string;
  thedow: integer;

begin
  thedow := dow;

  result := 'Sunday';
  if thedow=1 then result := 'Monday';
  if thedow=2 then result := 'Tuesday';
  if thedow=3 then result := 'Wednesday';
  if thedow=4 then result := 'Thursday';
  if thedow=5 then result := 'Friday';
  if thedow=6 then result := 'Saturday';

  cdow := result;
end;

function dayofmonth;

var
  y,m,d,dow: word;

begin
  getdate(y,m,d,dow);
  dayofmonth := d;
end;

function month;

var
  y,m,d,dow: word;

begin
  getdate(y,m,d,dow);
  month := m;
end;

function extmonthname;

var
  result: string;

begin
  result := 'January';
  if themonth=2  then result := 'February';
  if themonth=3  then result := 'March';
  if themonth=4  then result := 'April';
  if themonth=5  then result := 'May';
  if themonth=6  then result := 'June';
  if themonth=7  then result := 'July';
  if themonth=8  then result := 'August';
  if themonth=9  then result := 'September';
  if themonth=10 then result := 'October';
  if themonth=11 then result := 'November';
  if themonth=12 then result := 'December';

  extmonthname := result;
end;

function monthname;

begin
  monthname := extmonthname(month);
end;

function year;

var
  y,m,d,dow: word;

begin
  getdate(y,m,d,dow);
  year := y;
end;

function getenv;

var
  result: string;

  i: integer;
  envseg: word;
  envread: integer;
  firstb: byte;
  thisb: byte;
  varname: string;
  vardata: string;
  done: boolean;

begin
  result := '';

  envseg := memw[prefixseg:$2c];

  envread := 0;
  repeat
    firstb := mem[envseg:envread];

    if firstb>0 then
      begin
        varname := '';

        repeat
          thisb := mem[envseg:envread];
          inc(envread);
          if thisb<>ord('=') then
            varname := varname+chr(thisb);
        until thisb=ord('=');

        vardata := '';

        repeat
          thisb := mem[envseg:envread];
          inc(envread);
          if thisb>0 then
            vardata := vardata+chr(thisb);
        until thisb=0;

        done := (varname=s);
        if done then
          result := vardata;
    end;
  until (firstb=0) or done;

  getenv := result;
end;

function numoccur;

var
  result: integer;
  i: integer;

begin
  result := 0;

  for i := 1 to length(s) do
    if s[i]=c then
      inc(result);

  numoccur := result;
end;

function hasany;

begin
  hasany := (numoccur(c,s)<>0);
end;

function hasno;

begin
  hasno := not hasany(c,s);
end;

function unquote;

begin
  if (s[1]='"') and (s[length(s)]='"') then
    unquote := copy(s,2,length(s)-2)
  else
    unquote := s;
end;

function crepl;

var
  result: string;
  i: integer;

begin
  result := s;

  for i := 1 to length(result) do
    if result[i]=cold then
      result[i] := cnew;

  crepl := result;
end;

function unslash;

begin
  unslash := crepl(s,'/','\');
end;

function unbackslash;

begin
  if s='' then
    unbackslash := s
  else if copy(s,length(s),1)='\' then
    unbackslash := copy(s,1,length(s)-1)
  else
    unbackslash := s;
end;

function ununderscore;

begin
  ununderscore := crepl(s , '_' , ' ');
end;

function uncomma;

begin
  uncomma := crepl(s , ',' , ' ');
end;

{}{}{}{} { srepl('aa','a','') doesn't work :-( }

function srepl;

var
  result: string;
  at: integer;

begin
  result := s;
  if (sold<>'') and (sold<>snew) then
    begin
      at := 0;
      while at<=length(result)-length(sold) do
        begin
          inc(at);
          if result[at]=sold[1] then
            if copy(result,at,length(sold))=sold then
              begin
                if sold=result then
                  result := snew
                else if at=1 then
                  result := snew+copy(result,length(sold)+1,255)
                else if at=length(result)-length(sold)+1 then
                  result := copy(result,1,at-1)+snew
                else
                  result :=
                   copy(result,1,at-1)+snew+copy(result,at+length(sold),255);
            end;
        end;
    end;
  srepl := result;
end;

function unspace;

var
  result: string;
  i: integer;

begin
  if (numoccur(' ',s)=0) and (numoccur(tab,s)=0) then
    result := s
  else
    begin
      result := '';
      for i := 1 to length(s) do
        if (s[i]<>' ') and (s[i]<>tab) then
          result := result+s[i];
    end;

  unspace := result;
end;

function atow;

var
  result: word;
  code: word;

begin
  val(s,result,code);
  atow := result;
end;

function atoi;

var
  result: integer;
  code: word;

begin
  val(s,result,code);
  atoi := result;
end;

function atol;

var
  result: longint;
  code: word;

begin
  val(s,result,code);
  atol := result;
end;

function wtoa;

begin
  wtoa := wordtozstring(w,0);
end;

function itoa;

begin
  itoa := integertozstring(i,0);
end;

function ltoa;

begin
  ltoa := longtozstring(l,0);
end;

function lowcase; {similar to the supplied upcase}

begin
  if (c>='A') and (c<='Z') then
    lowcase := chr(ord(c)-ord('A')+ord('a'))
  else
    lowcase := c;
end;

function upper;

var
  result: string;
  i: integer;

begin
  result := s;

  for i := 1 to length(s) do
    result[i] := upcase(result[i]);

  upper := result;
end;

function lower;

var
  result: string;
  i: integer;

begin
  result := s;

  for i := 1 to length(s) do
    result[i] := lowcase(result[i]);

  lower := result;
end;

function proper;

var
  result: string;
  i: integer;

begin
  result := s;

  if length(s)>0 then
    if (result[1]>='a') and (result[1]<='z') then
      result[1] := upcase(result[1]);

  for i := 2 to length(s) do
    if (upcase(result[i])>='A') and (upcase(result[i])<='Z') then
      if result[i-1]=' ' then
        result[i] := upcase(result[i])
      else
        result[i] := lowcase(result[i]);

  proper := result;
end;

function ltrim;

var
  result: string;

begin
  result := s;

  while ((result[1]=' ') or (result[1]=tab)) and (length(result)>0) do
    result := copy(result,2,255);

  ltrim := result;
end;

function trim;

var
  result: string;

begin
  result := s;

  while ((result[length(result)]=' ') or (result[length(result)]=tab)) and
   (length(result)>0) do
    result := copy(result,1,length(result)-1);

  trim := result;
end;

function right;

begin
  right := copy(s,max(1,length(s)-i+1),i);
end;

function getfirstw;

var
  result: string;
  spaceat: integer;
  tabat: integer;

begin
  result := trim(ltrim(s));
  spaceat := pos(' ',result);
  tabat := pos(tab,result);

  if tabat>0 then
    if (spaceat>0) and (tabat>spaceat) then
      result := copy(result,1,spaceat-1)
    else
      result := copy(result,1,tabat-1)
  else
    if spaceat>0 then
      result := copy(result,1,spaceat-1);

  getfirstw := result;
end;

function chopfirstw;

var
  result: string;

begin
  s := trim(ltrim(s));
  result := getfirstw(s);
  s := trim(ltrim(copy(s,length(result)+1,255)));

  chopfirstw := result;
end;

function getquoted;

var
  result: string;

begin
  result := '';

  if copy(s,1,1)='"' then
    begin
      result := copy(s,2,255);
      if pos('"',result)=0 then
        result := getfirstw(result)
      else
        result := copy(result,1,pos('"',result)-1);
    end
  else
    result := getfirstw(s);

  getquoted := result;
end;

function randomletter;

begin
  if random(2)=0 then
    randomletter := chr(ord('a')+random(26))
  else
    randomletter := chr(ord('A')+random(26));
end;

function randomdigit;

begin
  randomdigit := chr(ord('0')+random(10));
end;

function getfromaddr;

var
  result: string;
  at: integer;

begin
  at := pos('<',from);

  if at>0 then {Full Name <address>}
    result := copy(from,at+1,length(from)-at-1)
  else
    begin
      at := pos(' ',from);
      if at>0 then {address (Full Name)}
        result := copy(from,1,at-1)
      else {address}
        result := from;
    end;

  getfromaddr := result;
end;

{be careful with address like

  "Some (Happy) User" <[e-mail]>

- need to grab the right parts right}

function getfromname;

var
  result: string;
  at: integer;

begin
  result := '';

  if copy(from,length(from),1)='>' then
    begin
      at := pos('<',from);
      if at>1 then
        result := copy(from,1,at-2);
    end;

  if result='' then
    begin
      at := pos('(',from);
      if at>0 then
        result := copy(from,at+1,length(from)-at-1)
      else
        begin
          at := pos('<',from);
          if at>1 then
            result := copy(from,1,at-2);
        end;
    end;

  getfromname := unquote(result);
end;

function chop;

var
  result: string;

begin
  chop := copy(s,i+1,255);
end;

function nore;

begin

{should always be 4 and 'Re: ', but uppercase and ltrim to deal with others}

  if upper(copy(s,1,3))='RE:' then
    nore := ltrim(chop(s,3))
  else
    nore := s;
end;

function monthstringtointeger;

var
  result: integer;
  lowermonthstr: string;

begin
  result := 12;

  lowermonthstr := lower(monthstr);

  if lowermonthstr='jan' then result := 1
  else if lowermonthstr='feb' then result := 2
  else if lowermonthstr='mar' then result := 3
  else if lowermonthstr='apr' then result := 4
  else if lowermonthstr='may' then result := 5
  else if lowermonthstr='jun' then result := 6
  else if lowermonthstr='jul' then result := 7
  else if lowermonthstr='aug' then result := 8
  else if lowermonthstr='sep' then result := 9
  else if lowermonthstr='oct' then result := 10
  else if lowermonthstr='nov' then result := 11;

  monthstringtointeger := result;
end;

function isalpha;

begin
  isalpha := ( (upcase(c)>='A') and (upcase(c)<='Z') );
end;

function isdigit;

begin
  isdigit := (c>='0') and (c<='9');
end;

function islower;

begin
  islower := (c>='a') and (c<='z');
end;

function snatchint;

var
  intsofar: integer;

begin
  intsofar := 0;

  while (length(s)>0) and not isdigit(s[1]) do
    s := chop(s,1);

  while (length(s)>0) and isdigit(s[1]) do
    begin
      intsofar := 10*intsofar+ord(s[1])-ord('0');
      s := chop(s,1);
    end;

  snatchint := intsofar;
end;

function isdev;

{isdev is not perfect -- it always stops on the 128th iteration, just in case}

var
  result: boolean;
  offs: word;
  segm: word;
  oldsegm: word;
  foundnul: boolean;
  basename: string;
  i: integer;
  iterations: integer;

begin
  result := false;

  iterations := 0;

  segm := 0;
  offs := $400;

  basename := upper(unslash(s));

{handle LPT1: case}
  if copy(basename,length(basename),1)=':' then
    basename := copy(basename,1,length(basename)-1);

{strip disk and path designators}
  while pos(':',basename)<>0 do
    basename := copy(basename,pos(':',basename)+1,255);
  while pos('\',basename)<>0 do
    basename := copy(basename,pos('\',basename)+1,255);

{strip anything after the first period}
  if pos('.',basename)<>0 then
    basename := copy(basename,1,pos('.',basename)-1);

{NUL is supposed to be guaranteed the first in the chain}
  foundnul := false;
  while (not foundnul) and (offs>0) do
    begin

{offs is always in range 1..400 here}

      if (mem[segm:offs]=ord('N')) and
       (mem[segm:offs+1]=ord('U')) and
       (mem[segm:offs+2]=ord('L')) and
       (mem[segm:offs+3]=ord(' ')) and
       (mem[segm:offs+4]=ord(' ')) and
       (mem[segm:offs+5]=ord(' ')) and
       (mem[segm:offs+6]=ord(' ')) and
       (mem[segm:offs+7]=ord(' ')) then
        begin

          if offs<6 then
            begin
              writeln('!! error in isdev: offs<6, first loop -- see source');
              halt(1);
            end;

{$ifdef devverbose}
          writeln('found NUL at ',offs);
          writeln('attrib=',memw[segm:offs-6]);
{$endif}

          if memw[segm:offs-6]=$8004 then
            begin

{$ifdef devverbose}
              writeln('looks like the real NUL to me!');
{$endif}

              foundnul := true;
            end;
        end;

      if not foundnul then
        inc(offs);
    end;

  if foundnul then
    begin

      while length(basename)<8 do
        basename := basename+' ';

      if offs<10 then
        begin
          inc(offs,32);
          dec(segm,2);
        end;

      if offs>65000 then
        begin
          dec(offs,32);
          inc(segm,2);
        end;

      while not result and
       (meml[segm:offs-10]<>$ffffffff) and
       (iterations<128) do

        begin
          inc(iterations);

          result := true;
          for i := 0 to 7 do
            result := result and (chr(mem[segm:offs+i])=basename[1+i]);

{$ifdef devverbose}
          writeln('name of device=',
           chr(mem[segm:offs]),
           chr(mem[segm:offs+1]),
           chr(mem[segm:offs+2]),
           chr(mem[segm:offs+3]),
           chr(mem[segm:offs+4]),
           chr(mem[segm:offs+5]),
           chr(mem[segm:offs+6]),
           chr(mem[segm:offs+7]),
           '.');

          writeln('new position: ',memw[segm:offs-10],':',memw[segm:offs-8]);
{$endif}

          oldsegm := segm;
          segm := memw[oldsegm:offs-8];
          offs := memw[oldsegm:offs-10];

          if offs<10 then
            begin
              inc(offs,32);
              dec(segm,2);
            end;

          if offs>65000 then
            begin
              dec(offs,32);
              inc(segm,2);
            end;

          offs := offs+10;

        end;

    end;

  if iterations>=128 then
    writeln('!! isdev exited due to iterations, not due to finding anything');

  isdev := result;
end;

{$ifdef testfn}
program testfn;

var
  i: integer;
  fn: string;
  f: text;

begin
  for i := 1 to 255 do
    begin
      fn := '';
      fn := fn+chr(((i        ) div 100)+ord('0'));
      fn := fn+chr(((i mod 100) div  10)+ord('0'));
      fn := fn+chr(((i mod  10)        )+ord('0'));
      fn := fn+'_';
      fn := fn+chr(i);
      assign(f,fn);
{$I-}
      rewrite(f);
{$I+}
      if ioresult=0 then
        close(f);

      writeln(i);
    end;
end.
{$endif}

function illegalfn;

const
  legalchars: set of char=
  [
   {uppercase letters}
   'A','B','C','D','E','F','G','H','I','J','K','L','M',
   'N','O','P','Q','R','S','T','U','V','W','X','Y','Z',

   {lowercase letters}
   'a','b','c','d','e','f','g','h','i','j','k','l','m',
   'n','o','p','q','r','s','t','u','v','w','x','y','z',

   {digits}
   '0','1','2','3','4','5','6','7','8','9',

   {some punctuation}
   '!','#','$','%','&','(',')','-','@','^','_','`','{','}','~',

   {must be careful with these}
   ':','.','\',

   {and finally, the quote}
   ''''
  ];

var
  result: boolean;
  i: integer;

begin
  result := false;

  if numoccur(':',fn)>1 then
    result := true
  else if numoccur('.',fn)>1 then
    result := true
  else if fn[1]='.' then
    result := true
  else
    for i := 1 to length(fn) do
      if not (fn[i] in legalchars) then
        result := true;

  illegalfn := result;
end;

function suspiciousfn;

{note that unslash must have already been used!}

var
  result: boolean;
  upfn: string;

begin
  result := false;
  upfn := upper(fn);

  if illegalfn(upfn) then
    result := true
  else if numoccur(':',upfn)>0 then
    result := true
  else if numoccur('\',upfn)>0 then
    result := true
  else {common devices just in case isdev misses them}
    if (upfn='CON') or
     (upfn='PRN') or
     (upfn='AUX') or
     (upfn='NUL') or
     (upfn='LPT1') or
     (upfn='LPT2') or
     (upfn='LPT3') or
     (upfn='COM1') or
     (upfn='COM2') or
     (upfn='COM3') or
     (upfn='COM4') or
     (upfn='CLOCK$') then
      result := true
  else {isdev uses icky memory peeking, so don't run it if you can avoid it}
    if isdev(upfn) then
      result := true;

  suspiciousfn := result;
end;

function highestartin;

var
  result: word;
  fileinfo: searchrec;

begin
  result := 0;

  findfirst(groupdir+'\'+'*',archive,fileinfo);
  while doserror=0 do
    begin
      result := max(result,atoi(fileinfo.name));
      findnext(fileinfo);
    end;

  highestartin := result;
end;

function getuniqfile;

var
  result: string;
  mangledgroupdir: string;

begin
  mangledgroupdir := groupdir;

{}{need to keep each directory under 8 chars}

{avoid problems when keeping outbox copy for mail to [e-mail] etc.}

  if isdev(mangledgroupdir) then
    begin
      mangledgroupdir := groupdir+'_';

{some device names are 8 chars, and just adding a `_' won't help}

      if isdev(mangledgroupdir) then
        mangledgroupdir := copy(groupdir,1,length(groupdir)-1)+'_';
    end;

  getuniqfile := mangledgroupdir+'\'+wtoa(highestartin(mangledgroupdir)+1);
end;

function getuniqfext;

var
  result: word;
  fileinfo: searchrec;
  filefound: string;
  mangledbasename: string;

begin
  result := 0;
  mangledbasename := basename;

{}{need to keep each directory under 8 chars}

{avoid problems when keeping outbox copy for mail to [e-mail] etc.}

  if isdev(mangledbasename) then
    begin
      mangledbasename := basename+'_';

{some device names are 8 chars, and just adding a `_' won't help}

      if isdev(mangledbasename) then
        mangledbasename := copy(basename,1,length(basename)-1)+'_';
    end;

  findfirst(mangledbasename+'.*',archive,fileinfo);
  while doserror=0 do
    begin
      filefound := fileinfo.name;
      while pos('.',filefound)>0 do
        filefound := copy(filefound,pos('.',filefound)+1,255);
      result := max(result,atoi(filefound));
      findnext(fileinfo);
    end;
  getuniqfext := mangledbasename+'.'+wtoa(result+1);
end;

function expand;

var
  work: string;
  i,j: integer;

begin
  if pos(tab,str)=0 then
    expand := str
  else
    begin
      work := '';
      for i := 1 to length(str) do
        if length(work)<240 then
          if str[i]=tab then
            for j := 1 to 8-(length(work) and 7) do
              work := work+' '
          else
            work := work+str[i];
      expand := work;
    end;
end;

function rot13;

var
  result: string;
  upc: char;
  i: integer;

begin
  result := s;

  for i := 1 to length(result) do
    begin
      upc := upcase(result[i]);
      if (upc>='A') and (upc<='M') then
        result[i] := chr(ord(result[i])+13)
      else if (upc>='N') and (upc<='Z') then
        result[i] := chr(ord(result[i])-13);
    end;

  rot13 := result;
end;

function indir;

var
  fileinfo: searchrec;

begin
  findfirst(dir+'\'+filespec,archive,fileinfo);
  indir := (doserror=0);
end;

function default;

begin
  if possiblyemptystr='' then
    default := defaultstr
  else
    default := possiblyemptystr;
end;

function rpos;

var
  result: integer;
  i: integer;

begin
  result := 0;

  for i := 1 to length(whole)-length(sub)+1 do
    if copy(whole,i,length(sub))=sub then
      result := i;

  rpos := result;
end;

function rposc;

var
  result: integer;
  i: integer;

begin
  result := 0;

  for i := 1 to length(s) do
    if s[i]=c then
      result := i;

  rposc := result;
end;

function fexists;

var
  result: boolean;
  f: text;

begin
  result := false;

  assign(f,fn);
{$I-}
  reset(f);
{$I+}
  if ioresult=0 then
    begin
      close(f);
      result := true;
    end;

  fexists := result;
end;

function dexists;

var
  result: boolean;
  fileinfo: searchrec;

begin
  result := false;

  findfirst(dn,directory,fileinfo);

  if doserror=0 then
    if (fileinfo.attr and directory)<>0 then
      result := true;

  dexists := result;
end;

function ftimestamp;

var
  result: longint;
  f: text;

begin
  result := 0;

  assign(f,fn);
{$I-}
  reset(f);
{$I+}
  if ioresult=0 then
    begin
      getftime(f,result);
      close(f);
    end;

  ftimestamp := result;
end;

function withbackslash;  {nonempty gets terminated with backslash}

var
  result: string;

begin
  result := s;
  if result<>'' then
    if result[length(result)]<>'\' then
      result := result+'\';

  withbackslash := result;
end;

function nobeep;

var
  result: string;

begin
  result := crepl(s,chr(7),'^');
  nobeep := result;
end;

function nonastychar;

var
  result: string;

begin
  result := crepl(s,chr(7),'^');
  result := crepl(result,chr(27),'^');
  nonastychar := result;
end;

function gettag;

var
  result: string;

begin
  result := '';

  if pos(tag,s)<>0 then
    begin
      result := copy(s,pos(tag,s)+length(tag),255);
      result := getquoted(result);
    end;

  gettag := result;
end;

function hexchar;

begin
  if i<10 then
    hexchar := chr(ord('0')+i)
  else
    hexchar := chr(ord('a')+i-10);
end;

function partialmatch;

var
  result: boolean;

begin
  result := false;

  if (length(cmd)<=length(template)) and (length(cmd)>=length(minimum)) then
    if copy(template,1,length(cmd))=cmd then
      result := true;

  partialmatch := result;
end;

function doserrorno;  {prevents units having to include dos for 1 call}

begin
  doserrorno := doserror;
end;

function wordwith;

var
  result: string;
  temps: string;

begin
  result := '';
  temps := s;

  while (result='') and (temps<>'') do
    begin
      result := chopfirstw(temps);
      if pos(c,result)=0 then
        result := '';
    end;

  wordwith := result;
end;

function isasciifile;

const
  checkedsize=1024;

var
  result: boolean;

{$ifdef veryslowisasciifile}
  inf: file of byte;
{$endif}
  inf: file;
  whichbyte: integer;
  onebyte: byte;
{$ifdef veryslowisasciifile}
  stillsearching: boolean;
{$endif}
  buffer: array[1..checkedsize] of byte;
  numread: word;

begin
  result := true;

{$ifdef veryslowisasciifile}
  assign(inf,fn);
{$I-}
  reset(inf);
{$I+}
{$endif}

  assign(inf,fn);
{$I-}
  reset(inf,1);
{$I+}

  if ioresult<>0 then
    result := false
  else
    begin
{$ifdef veryslowisasciifile}
      stillsearching := true;

      for whichbyte := 1 to checkedsize do
        if stillsearching then
          begin
            if eof(inf) then
              stillsearching := false
            else
              begin
                read(inf,onebyte);
                if not
                (
                 (onebyte=9)
                or
                 (onebyte=10)
                or
                 (onebyte=13)
                or
                 ( (onebyte>=32) and (onebyte<=126) )
                )
                  then
                    begin
                      result := false;
                      stillsearching := false;
                    end;
              end;
          end;
      close(inf);
{$endif}

      blockread(inf,buffer,checkedsize,numread);
      close(inf);

      for whichbyte := 1 to numread do
        if result then
          begin
            onebyte := buffer[whichbyte];
            if not
            (
             (onebyte=9)
            or
             (onebyte=10)
            or
             (onebyte=13)
            or
             ( (onebyte>=32) and (onebyte<=126) )
            )
              then
                result := false;
          end;

    end;

  isasciifile := result;
end;

{$ifdef VER40}
function dosversion;

var
  regs: registers;

begin
  regs.ah := $30;
  msdos(regs);
  dosversion := regs.ax;
end;
{$endif}

{$ifdef floatingpoint}
function ator;

var
  r: real;
  code: word;

begin
  val(s,r,code);
  ator := r;
end;

function rtoa;

var
  a: string;

begin
  str(r,a);
  rtoa := a;
end;

function rwptoa;

var
  a: string;

begin
  str(r:width:precision,a);
  rwptoa := a;
end;
{$endif}

end.